home *** CD-ROM | disk | FTP | other *** search
/ Dictionaries & Language / Dictionaries and Language (Chestnut CD-ROM) (1993).iso / misc / vb30 / vbdircpm.inc < prev    next >
Encoding:
Text File  |  1986-02-07  |  4.6 KB  |  151 lines
  1.  
  2. {****************************************************************}
  3. {*                                                              *}
  4. {*                    VB Directory Routines                     *}
  5. {*                                                              *}
  6. {*                    *** CP/M  Version ***                     *}
  7. {*                                                              *}
  8. {****************************************************************}
  9.  
  10.  
  11.   procedure DirWordList;
  12.   { derive and print a directory list of word files }
  13.  
  14.     type
  15.       DirPointer   = ^DirRecord;
  16.       DirRecord    = record
  17.                        DirName  : ListName;
  18.                        Next     : DirPointer;
  19.                      end;
  20.  
  21.     var
  22.       HeapTop      : ^integer;
  23.       FirstEntry,
  24.       LastEntry,
  25.       NewEntry     : DirPointer;
  26.       FileName     : ListName;
  27.       OK           : boolean;
  28.       DMA          : array[1..128] of byte;
  29.       FCB          : array [1..36] of byte;
  30.       FCB_Address  : integer;
  31.       j            : integer;
  32.  
  33.       procedure SetFCB;
  34.       { set up file control block for directory search }
  35.         const
  36.           SetDMA_Address = 26;
  37.         var
  38.           DMA_Address    : integer;
  39.           i              : integer;
  40.         begin
  41.           FCB[1] :=  0;
  42.           for i := 2 to 9 do
  43.             FCB[i] := ord('?');
  44.           for i := 1 to 3 do
  45.             FCB[i + 9] := ord(Extent[i]);
  46.           for i := 13 to 36 do
  47.             FCB[i] := 0;
  48.           DMA_Address := addr(DMA);
  49.           FCB_Address := addr(FCB);
  50.           bdos(SetDMA_Address,DMA_Address)
  51.         end;
  52.  
  53.       procedure GetFirst(var FileName: ListName; var OK: boolean);
  54.       { locate the first directory entry that matches the wildcard }
  55.         const
  56.           SearchForFirst = 17;
  57.         var
  58.           i,j            : integer;
  59.         begin
  60.           i := bdos(SearchForFirst,FCB_Address);
  61.           OK := i <> 255;
  62.           if OK
  63.             then
  64.               begin
  65.                 i := i * 32;
  66.                 FileName := '';
  67.                 for j := 2 to 9 do
  68.                   FileName := FileName + chr(DMA[j + i])
  69.               end
  70.         end;
  71.  
  72.       procedure GetNext(var FileName: ListName; var OK: boolean);
  73.       { locate the next directory entry that matches the wildcard }
  74.         const
  75.           SearchForNext = 18;
  76.         var
  77.           i,j            : integer;
  78.         begin
  79.           i := bdos(SearchForNext,FCB_Address);
  80.           OK := i <> 255;
  81.           if OK
  82.             then
  83.               begin
  84.                 i := i * 32;
  85.                 FileName := '';
  86.                 for j := 2 to 9 do
  87.                   FileName := FileName + chr(DMA[j + i])
  88.               end
  89.         end;
  90.  
  91.     begin { DirWordList }
  92.       FirstEntry := nil;
  93.       Mark(HeapTop);
  94.       SetFCB;
  95.       GetFirst(FileName,OK);
  96.       if OK
  97.         then
  98.           begin
  99.             New(NewEntry);
  100.             NewEntry^.DirName := FileName;
  101.             FirstEntry := NewEntry;
  102.             LastEntry := NewEntry;
  103.             LastEntry^.Next := nil;
  104.             repeat
  105.               GetNext(FileName,OK);
  106.               if OK
  107.                 then
  108.                   begin
  109.                     New(NewEntry);
  110.                     NewEntry^.DirName := FileName;
  111.                     LastEntry^.Next := NewEntry;
  112.                     LastEntry := NewEntry;
  113.                     LastEntry^.Next := nil
  114.                   end
  115.             until not OK
  116.           end;
  117.       writeln;
  118.       while FirstEntry <> nil do
  119.         begin
  120.           for j := 1 to 20 do
  121.             write (' ');
  122.           write (FirstEntry^.DirName);
  123.           if (8 - length(FirstEntry^.DirName)) > 0
  124.             then
  125.               for j := 1 to (8 - length(FirstEntry^.DirName)) do
  126.                 write (' ');
  127.           write ('  |  ');
  128.           FirstEntry := FirstEntry^.Next;
  129.           if FirstEntry <> nil
  130.             then
  131.               begin
  132.                 write (FirstEntry^.DirName);
  133.                 if (8 - length(FirstEntry^.DirName)) > 0
  134.                   then
  135.                     for j := 1 to (8 - length(FirstEntry^.DirName)) do
  136.                       write (' ');
  137.                 write ('  |  ');
  138.                 FirstEntry := FirstEntry^.Next;
  139.                 if FirstEntry <> nil
  140.                   then
  141.                     begin
  142.                       writeln (FirstEntry^.DirName);
  143.                       FirstEntry := FirstEntry^.Next
  144.                     end
  145.               end
  146.         end;
  147.       writeln;
  148.       Release(HeapTop)
  149.     end;
  150.  
  151.